home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xaw / pulldown < prev    next >
Encoding:
Text File  |  1992-10-01  |  1.5 KB  |  47 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Pulldown menu demo
  4.  
  5. (require 'xwidgets)
  6. (load-widgets shell menubutton simplemenu smebsb smeline sme)
  7.  
  8. (define top (application-initialize 'pulldown))
  9.  
  10. (define mb (create-managed-widget (find-class 'menubutton) top))
  11. (set-values! mb 'label "Please press left button" 'menu-name 'the-menu)
  12.  
  13. ;; Due to a bug in the X11R5 SimpleMenu widget the `label' resource
  14. ;; can only be set at widget creation time:
  15. ;;
  16. (define menu (create-popup-shell 'the-menu (find-class 'simplemenu) mb
  17.   'label 'menu))
  18.  
  19. (define data "\0\0\0\6\0\3\0\3\200\1\206\1\316\0\314\0\170\0\160\0\40\0\0\0")
  20. (define bm (create-bitmap-from-data (display-root-window (widget-display top))
  21.                     data 12 12))
  22.  
  23. (define (selected w)
  24.   (format #t "~s selected~%" (widget-name w)))
  25.  
  26. (for-each
  27.   (lambda (e)
  28.     (if e
  29.         (if (eqv? e "")
  30.         (create-managed-widget (find-class 'sme) menu 'height 10)
  31.             (create-managed-widget e (find-class 'smebsb) menu
  32.               'vert-space 40 'label e 'callback (list selected)))
  33.         (create-managed-widget (find-class 'smeline) menu)))
  34.   '("hamburger" "fishburger" "pommes frites" "" "chicken nuggets"
  35.     "chicken wings" #f "cola" "milk shake" #f))
  36.  
  37. (define w (create-managed-widget (find-class 'smebsb) menu))
  38. (set-values! w 'vert-space 50 'left-bitmap bm 'label "eat here"
  39.                'left-margin 16)
  40. (add-callback w 'callback
  41.   (lambda (w)
  42.     (set-values! w 'left-bitmap
  43.       (if (eq? (car (get-values w 'left-bitmap)) 'none) bm 'none))))
  44.     
  45. (realize-widget top)
  46. (context-main-loop (widget-context top))
  47.